home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / library / init.tcl < prev    next >
Encoding:
Text File  |  1993-11-05  |  7.9 KB  |  267 lines  |  [TEXT/MPS ]
  1. #----------
  2. # This file has been modified for Macintosh Tcl and Tickle. -- Tim Endres
  3. #----------
  4. # puts stdout "••• init.tcl"
  5.  
  6. # init.tcl --
  7. #
  8. # Default system startup file for Tcl-based applications.  Defines
  9. # "unknown" procedure and auto-load facilities.
  10. #
  11. # $Header: /user6/ouster/tcl/library/RCS/init.tcl,v 1.26 93/09/17 15:55:53 ouster Exp $ SPRITE (Berkeley)
  12. #
  13. # Copyright (c) 1991-1993 The Regents of the University of California.
  14. # All rights reserved.
  15. #
  16. # Permission is hereby granted, without written agreement and without
  17. # license or royalty fees, to use, copy, modify, and distribute this
  18. # software and its documentation for any purpose, provided that the
  19. # above copyright notice and the following two paragraphs appear in
  20. # all copies of this software.
  21. #
  22. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  23. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  24. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  25. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26. #
  27. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  28. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  29. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  30. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  31. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  32. #
  33.  
  34. set auto_path [info library]
  35.  
  36. # unknown:
  37. # Invoked when a Tcl command is invoked that doesn't exist in the
  38. # interpreter:
  39. #
  40. #    1. See if the autoload facility can locate the command in a
  41. #       Tcl script file.  If so, load it and execute it.
  42. #    2. See if the command exists as an executable UNIX program.
  43. #       If so, "exec" the command.
  44. #    3. If the command was invoked at top-level:
  45. #        (a) see if the command requests csh-like history substitution
  46. #        in one of the common forms !!, !<number>, or ^old^new.  If
  47. #        so, emulate csh's history substitution.
  48. #        (b) see if the command is a unique abbreviation for another
  49. #        command.  If so, invoke the command.
  50.  
  51. proc unknown args {
  52.     global auto_noexec auto_noload env unknown_pending tcl_interactive;
  53.  
  54.     set name [lindex $args 0]
  55.     if ![info exists auto_noload] {
  56.     #
  57.     # Make sure we're not trying to load the same proc twice.
  58.     #
  59.     if [info exists unknown_pending($name)] {
  60.         unset unknown_pending($name)
  61.         if {[array size unknown_pending] == 0} {
  62.         unset unknown_pending
  63.         }
  64.         return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
  65.     }
  66.     set unknown_pending($name) pending;
  67.     set ret [catch {auto_load $name} msg]
  68.     unset unknown_pending($name);
  69.     if {$ret != 0} {
  70.         return -code $ret "error while autoloading \"$name\": $msg"
  71.     }
  72.     if ![array size unknown_pending] {
  73.         unset unknown_pending
  74.     }
  75.     if $msg {
  76.         return [uplevel $args]
  77.     }
  78.     }
  79.     if {([info level] == 1) && ([info script] == "") && $tcl_interactive} {
  80.     if ![info exists auto_noexec] {
  81.         if [auto_execok $name] {
  82.         return [uplevel exec >&@stdout <@stdin $args]
  83.         }
  84.     }
  85.     if {$name == "!!"} {
  86.         return [uplevel {history redo}]
  87.     }
  88.     if [regexp {^!(.+)$} $name dummy event] {
  89.         return [uplevel [list history redo $event]]
  90.     }
  91.     if [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
  92.         return [uplevel [list history substitute $old $new]]
  93.     }
  94.     set cmds [info commands $name*]
  95.     if {[llength $cmds] == 1} {
  96.         return [uplevel [lreplace $args 0 0 $cmds]]
  97.     }
  98.     if {[llength $cmds] != 0} {
  99.         if {$name == ""} {
  100.         return -code error "empty command name \"\""
  101.         } else {
  102.         return -code error \
  103.             "ambiguous command name \"$name\": [lsort $cmds]"
  104.         }
  105.     }
  106.     }
  107.     return -code error "invalid command name \"$name\""
  108. }
  109.  
  110. # auto_load:
  111. # Checks a collection of library directories to see if a procedure
  112. # is defined in one of them.  If so, it sources the appropriate
  113. # library file to create the procedure.  Returns 1 if it successfully
  114. # loaded the procedure, 0 otherwise.
  115.  
  116. proc auto_load cmd {
  117.     global auto_index auto_oldpath auto_path env errorInfo errorCode
  118.  
  119.     if [info exists auto_index($cmd)] {
  120.     uplevel #0 $auto_index($cmd)
  121.     return 1
  122.     }
  123.     if [catch {set path $auto_path}] {
  124.     if [catch {set path $env(TCLLIBPATH)}] {
  125.         if [catch {set path [info library]}] {
  126.         return 0
  127.         }
  128.     }
  129.     }
  130.     if [info exists auto_oldpath] {
  131.     if {$auto_oldpath == $path} {
  132.         return 0
  133.     }
  134.     }
  135.     set auto_oldpath $path
  136.     catch {unset auto_index}
  137.     foreach dir $path {
  138.     set f ""
  139.     if [catch {set f [open $dir:tclIndex]} cresult] {
  140.         continue
  141.     }
  142.     set error [catch {
  143.         set id [gets $f]
  144.         if {$id == "# Tcl autoload index file, version 2.0"} {
  145.         eval [read $f]
  146.         } elseif {$id == "# Tcl autoload index file: each line identifies a Tcl"} {
  147.         while {[gets $f line] >= 0} {
  148.             if {([string index $line 0] == "#")
  149.                 || ([llength $line] != 2)} {
  150.             continue
  151.             }
  152.             set name [lindex $line 0]
  153.             if {![info exists auto_index($name)]} {
  154.             set auto_index($name) "source $dir:[lindex $line 1]"
  155.             }
  156.         }
  157.         } else {
  158.         error "$dir:tclIndex isn't a proper Tcl index file"
  159.         }
  160.     } msg]
  161.     if {$f != ""} {
  162.         close $f
  163.     }
  164.     if $error {
  165.         error $msg $errorInfo $errorCode
  166.     }
  167.     }
  168.     if [info exists auto_index($cmd)] {
  169.     uplevel #0 $auto_index($cmd)
  170.     if {[info commands $cmd] != ""} {
  171.         return 1
  172.     }
  173.     }
  174.     return 0
  175. }
  176.  
  177. # auto_execok:
  178. # Returns 1 if there's an executable in the current path for the
  179. # given name, 0 otherwise.  Builds an associative array auto_execs
  180. # that caches information about previous checks, for speed.
  181.  
  182. proc auto_execok name {
  183.     global auto_execs env
  184.  
  185.     if [info exists auto_execs($name)] {
  186.     return $auto_execs($name)
  187.     }
  188.     set auto_execs($name) 0
  189.     if {[string first : $name] >= 0} {
  190.     if {[file executable $name] && ![file isdirectory $name]} {
  191.         puts "special, ok!"
  192.         set auto_execs($name) 1
  193.     }
  194.     return $auto_execs($name)
  195.     }
  196.     foreach dir [split $env(PATH) :] {
  197.     if {[file executable $dir:$name] && ![file isdirectory $dir:$name]} {
  198.         set auto_execs($name) 1
  199.         return 1
  200.     }
  201.     }
  202.     return 0
  203. }
  204.  
  205. # auto_reset:
  206. # Destroy all cached information for auto-loading and auto-execution,
  207. # so that the information gets recomputed the next time it's needed.
  208. # Also delete any procedures that are listed in the auto-load index
  209. # except those related to auto-loading.
  210.  
  211. proc auto_reset {} {
  212.     global auto_execs auto_index auto_oldpath
  213.     foreach p [info procs] {
  214.     if {[info exists auto_index($p)] && ($p != "unknown")
  215.         && ![string match auto_* $p]} {
  216.         rename $p {}
  217.     }
  218.     }
  219.     catch {unset auto_execs}
  220.     catch {unset auto_index}
  221.     catch {unset auto_oldpath}
  222. }
  223.  
  224. # auto_mkindex:
  225. # Regenerate a tclIndex file from Tcl source files.  Takes as argument
  226. # the name of the directory in which the tclIndex file is to be placed,
  227. # floowed by any number of glob patterns to use in that directory to
  228. # locate all of the relevant files.
  229.  
  230. proc auto_mkindex {dir args} {
  231.     global errorCode errorInfo
  232.     set oldDir [pwd]
  233.     cd $dir
  234.     set dir [pwd]
  235.     append index "# Tcl autoload index file, version 2.0\n"
  236.     append index "# This file is generated by the \"auto_mkindex\" command\n"
  237.     append index "# and sourced to set up indexing information for one or\n"
  238.     append index "# more commands.  Typically each line is a command that\n"
  239.     append index "# sets an element in the auto_index array, where the\n"
  240.     append index "# element name is the name of a command and the value is\n"
  241.     append index "# a script that loads the command.\n\n"
  242.     foreach file [eval glob $args] {
  243.     set f ""
  244.     set error [catch {
  245.         set f [open $file]
  246.         while {[gets $f line] >= 0} {
  247.         if [regexp {^proc[     ]+([^     ]*)} $line match procName] {
  248.             append index "set [list auto_index($procName)]"
  249.             append index " \"source \$dir:$file\"\n"
  250.         }
  251.         }
  252.         close $f
  253.     } msg]
  254.     if $error {
  255.         set code $errorCode
  256.         set info $errorInfo
  257.         catch {close $f}
  258.         cd $oldDir
  259.         error $msg $info $code
  260.     }
  261.     }
  262.     set f [open tclIndex w]
  263.     puts $f $index nonewline
  264.     close $f
  265.     cd $oldDir
  266. }
  267.